perm filename CALC.TAP[2,VDS] blob
sn#208024 filedate 1976-03-19 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00011 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C MAIN PROGRAM -- "SYSTEM MONITOR"
C00020 00003 JJ=X(II,1)
C00038 00004 8 K=K+1
C00052 00005 * /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C00068 00006 13 TEMPF=.TRUE.
C00083 00007 EXP(1)=RX(2)
C00099 00008 END
C00114 00009 CODE=51
C00130 00010 6 CALL SETUP (RTRN)
C00145 00011 * /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
C00158 ENDMK
C⊗;
C MAIN PROGRAM -- "SYSTEM MONITOR"
C DATE OF LAST CHANGE - 750104
IMPLICIT INTEGER (A-Z)
LOGICAL START, NEXT, FIXFLG, DECODE
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /OUTPT/ SKIP, DISPLY(32), PGMPTR, READER, PRINTR
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
C ** DEFINE LOGICAL UNIT NUMBERS FOR INPUT & OUTPUT DEVICES
READER=8
PRINTR=6
C ** START EXECUTION OF THE SIMULATION
10 DO 20 II=2,21
DO 20 JJ=1,17
IF (JJ.LT.12) UFLAG(JJ)=0
20 R(II,JJ)=15
R(21,2)=1
R(21,3)=5
DO 30 II=4,16
30 R(21,II)=0
R(21,17)=1
C
C REGISTERS ARE ALLOCATED AS FOLLOWS: R(1)="PI", R(2)="A",
C R(3)="LST X", R(4)="LST Y", R(5)="R0", ..., R(20)="R15",
C R(21)="HIGHEST REG NUMBER AVAILABLE"
C
C ** CONTROL PARAMETERS
C
C DECODE = KEY-CODE INPUT (T -> ENCODED KEYS, F -> NUMERIC CODES)
C SKIP = OUTPUT CONTROL (0 -> FULL STACK, 1 -> SHORT STACK,
C 2 -> DISPLAY & REGISTERS, 3 -> DISPLAY)
C FIXFLG = "DISPLAY" CONTROL (T -> "FIX" MODE)
C FIX = NUMBER OF DECIMAL DIGITS IN "FIX" MODE (0-9)
C SCI = NUMBER OF DIGITS IN "SCI" MODE (1-10)
C SMAX = NUMBER OF REGISTERS IN THE "STACK"
C
40 DECODE=.TRUE.
SKIP=3
FIXFLG=.TRUE.
FIX=2
SCI=5
SMAX=10
C
WRITE (PRINTR,1000)
READ (READER,1800) START
IF (START) GO TO 70
WRITE (PRINTR,1100)
READ (READER,1800) DECODE
WRITE (PRINTR,1200)
READ (READER,1900) SKIP
IF (SKIP.GT.1) GO TO 50
WRITE (PRINTR,1300)
READ (READER,1900) KEY
IF (KEY.NE.R(1,11)) GO TO 40
50 WRITE (PRINTR,1400)
READ (READER,1800) START
IF (START) GO TO 60
WRITE (PRINTR,1500)
READ (READER,1800) FIXFLG
WRITE (PRINTR,1600)
READ (READER,1900) FIX, SCI
SCI=SCI+1
60 WRITE (PRINTR,1700)
READ (READER,1900) SMAX
IF (SMAX.EQ.0) SMAX=10
C CONSIDER 100 TEST EQUATIONS
70 DO 380 TEST=1,100
ERROR=0
KEY=0
DO 80 II=1,50
80 EXPR(II)=15
CALL CLEAR
WRITE (PRINTR,2000) TEST
CALL OUTPUT (-1)
C OUTPUT CURRENT INFO & OBTAIN NEXT KEY-CODE
90 CALL CONTRL (1, SKIP)
C DECODE KEY-CODE
IF (NEXT) NEXT=.FALSE.
IF (CODE.LE.12) GO TO 130
IF (CODE.GT.19) GO TO 100
IF (CODE.EQ.13 .OR. CODE.EQ.14) GO TO 140
IF (CODE.EQ.15) GO TO 90
IF (CODE.EQ.18) GO TO 160
GO TO 150
100 IF (CODE.GT.29) GO TO 110
IF (CODE.EQ.20) GO TO 170
IF (CODE.EQ.22) GO TO 180
IF (CODE.EQ.23 .OR. CODE.EQ.24) GO TO 220
IF (CODE.EQ.25) GO TO 230
IF (CODE.EQ.26) GO TO 240
IF (CODE.EQ.27) GO TO 250
IF (CODE.EQ.28) GO TO 260
GO TO 270
110 IF (CODE.GT.39) GO TO 120
IF (CODE.EQ.31) GO TO 280
IF (CODE.EQ.32) GO TO 290
IF (CODE.EQ.33) GO TO 300
IF (CODE.EQ.34) GO TO 310
IF (CODE.EQ.35) GO TO 320
IF (CODE.EQ.36) GO TO 150
IF (CODE.EQ.37) GO TO 330
GO TO 220
120 IF (CODE.LT.44) GO TO 150
IF (CODE.EQ.44 .OR. CODE.EQ.45) GO TO 190
IF (CODE.EQ.46 .OR. CODE.EQ.47) GO TO 200
IF (CODE.EQ.48) GO TO 210
IF (CODE.EQ.49) GO TO 190
IF (CODE.EQ.50) GO TO 340
IF (CODE.EQ.51) GO TO 350
IF (CODE.EQ.52) GO TO 360
C KEY-CODE ERROR?
IF (CODE.EQ.98) STOP
IF (CODE.EQ.99) GO TO 10
GO TO 90
C CALL KEY ROUTINE
130 CALL ENTRY
GO TO 370
140 CALL SIGN
GO TO 370
150 CALL OPRATR
GO TO 370
160 CALL LPAREN
GO TO 370
170 CALL RPAREN (1)
GO TO 370
180 CALL EQUAL
GO TO 370
190 CALL FUNCTN (1)
GO TO 370
200 CALL FUNCTN (3)
GO TO 370
210 CALL FUNCTN (4)
GO TO 370
220 CALL RECALL (1)
GO TO 370
230 CALL RECALL (2)
GO TO 370
240 CALL CLEAR
GO TO 380
250 CALL CLEARX (1)
GO TO 370
260 CALL CORECT (2)
GO TO 370
270 CALL DRPSTK
GO TO 370
280 CALL STORE (1)
GO TO 370
290 CALL FIXN
GO TO 370
300 CALL SCIN
GO TO 370
310 CALL IMEDEX
GO TO 370
320 CALL EXCH
GO TO 370
330 CALL COMMA
GO TO 370
340 CALL SCR (1)
GO TO 370
350 CALL FLAG (1)
GO TO 370
360 CALL STPNUM (0)
C GO BACK AND GET ANOTHER KEY-STROKE
370 GO TO 90
380 CONTINUE
STOP
1000 FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'
* /' ACCEPT "ENCODED" KEY-CODES'
* /' PRODUCE "DISPLAY ONLY" OUTPUT'
* /' DISPLAY IN "FIX MODE" WITH FIX=2 & SCI=4'
* /' USE A 10 LEVEL "STACK"'
* //' THESE ARE OKAY. ("T" OR "F")'/)
1100 FORMAT (/' ENCODED KEY-CODES ARE TO BE ENTERED. ("T"/"F")'/)
1200 FORMAT (/' ENTER CODE FOR DESIRED OUTPUT: 0 = LONG STACK'
* /33X,'1 = SHORT STACK'/33X,'2 = DISPLAY & REGISTERS'
* /33X,'3 = DISPLAY ONLY'/)
1300 FORMAT (/' A KEYWORD IS NEEDED FOR THAT OUTPUT.'/)
1400 FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
* ' ("T" OR "F")'/)
1500 FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. ("T"/"F")'/)
1600 FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
* /' AND SCI MODES, RESPECTIVELY. ("N <SP> M")'/)
1700 FORMAT (/' ENTER NUMBER OF STACK REGISTERS WANTED',
* ' (1, 2, ..., 9, 0)'/)
1800 FORMAT (L1)
1900 FORMAT (I1, 1X, I1)
2000 FORMAT (' TEST NO.',I3/)
END
C///////////////////////////////////////////////////////////////////////
BLOCK DATA
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, STEPNO
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /OUTPT/ SKIP, DISPLY(32), PGMPTR, READER, PRINTR
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DATA NEXT /.FALSE./, STEPNO /.FALSE./, UFLAG /11*0/,
* CODE /-1/, PGMPTR /0/, W /17*0/, LFRC /0/, TEMP /0/,
* R(1,1),R(1,2),R(1,3),R(1,4),R(1,5),R(1,6),R(1,7),R(1,8),
* R(1,9),R(1,10),R(1,11),R(1,12),R(1,13),R(1,14),R(1,15),
* R(1,16),R(1,17) /15,3,1,4,1,5,9,2,6,5,3,5,9,0,15,0,0/
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE OUTPUT (PRINT)
C DATE OF LAST CHANGE - 741118
IMPLICIT INTEGER (A-Z)
DIMENSION CHAR(56), STROKE(41), SIGN(10), ESN(10), REG(17),
* DISP(32), DISP2(16), NAME(3)
LOGICAL EEX, DP, NEXT, FIXFLG, STEPNO
DOUBLE PRECISION NAME
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
2 /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
3 /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
4 /OUTPT/ SKIP, DISPLY(32), PGMPTR, READER, PRINTR
5 /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
DATA CHAR( 1),CHAR( 2),CHAR( 3),CHAR( 4)/'1 ','2 ','3 ','4 '/,
2 CHAR( 5),CHAR( 6),CHAR( 7),CHAR( 8)/'5 ','6 ','7 ','8 '/,
3 CHAR( 9),CHAR(10),CHAR(11),CHAR(12)/'9 ','0 ','. ','E '/,
4 CHAR(13),CHAR(14),CHAR(15),CHAR(16)/'- ','+ ',' ','/ '/,
5 CHAR(17),CHAR(18),CHAR(19),CHAR(20)/'* ','( ','**',') '/,
6 CHAR(21),CHAR(22),CHAR(23),CHAR(24)/'O ','= ','A ','PI'/,
7 CHAR(25),CHAR(26),CHAR(27),CHAR(28)/'R ','CL','CD','CO'/,
8 CHAR(29),CHAR(30),CHAR(31),CHAR(32)/'DR','LK','ST','FX'/,
9 CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SI','IX','XC','; '/,
A CHAR(37),CHAR(38),CHAR(39),CHAR(40)/', ','LX','LY','EQ'/,
B CHAR(41),CHAR(42),CHAR(43),CHAR(44)/'NE','GT','LT','MG'/,
C CHAR(45),CHAR(46),CHAR(47),CHAR(48)/'AG','AB','SR','SQ'/,
D CHAR(49),CHAR(50),CHAR(51),CHAR(52)/'MX','SC','FL','KL'/,
E CHAR(53),CHAR(54),CHAR(55),CHAR(56)/'XX','XX','XX','XX'/
DATA NAME /' A =', 'LAST X =', 'LAST Y ='/
C VARIOUS VALUES OF "SKIP" GIVE: -1 → CLEAR EXPRESSION
C 0 → LONG OUTPUT
C 1 → SHORT OUTPUT
C 2 → DISPLAY & REGISTERS
C 3 → DISPLAY ONLY
C
SKIP2=SKIP
IF (PRINT.LT.SKIP) SKIP2=PRINT
IF (SKIP2.GE.0) GO TO 20
DO 10 II=1,41
10 STROKE(II)=CHAR(15)
RETURN
20 IF (KEY.EQ.0) GO TO 50
IF (KEY.LT.41) GO TO 40
KEY=21
DO 30 II=1,21
EXPR(II)=EXPR(II+20)
STROKE(II)=STROKE(II+20)
30 STROKE(II+20)=CHAR(15)
40 JJ=EXPR(KEY)
IF (JJ.EQ.0) JJ=10
STROKE(KEY)=CHAR(JJ)
WRITE (PRINTR,1000) (STROKE(II),II=1,KEY)
50 IF (SKIP2.GT.1) GO TO 70
KK=SMAX
IF (SKIP2.EQ.1) KK=2
DO 60 II=1,KK
JJ=X(II,1)
IF (JJ.EQ.0) JJ=10
SIGN(II)=CHAR(JJ)
JJ=X(II,15)
IF (JJ.EQ.0) JJ=10
60 ESN(II)=CHAR(JJ)
70 DO 80 II=1,32
JJ=DISPLY(II)
IF (JJ.EQ.0) JJ=10
80 DISP(II)=CHAR(JJ)
DO 90 II=1,16
JJ=DSP(II)
IF (JJ.EQ.0) JJ=10
90 DISP2(II)=CHAR(JJ)
IF (SKIP2.GT.1) GO TO 120
IF (SKIP2.EQ.1) GO TO 110
WRITE (PRINTR,1100) DP, L, EEX, M, FIXFLG, FIX, NEXT,
* SCI, STEPNO, ERROR
IF (SMAX.LT.3) GO TO 110
WRITE (PRINTR,1200) SMAX, P(SMAX), SIGN(SMAX),
* (X(SMAX,NN),NN=2,14), ESN(SMAX),
* X(SMAX,16), X(SMAX,17), OP(SMAX)
IF (SMAX.EQ.3) GO TO 110
JJ=SMAX-3
DO 100 II=1,JJ
KK=SMAX-II
100 WRITE (PRINTR,1300) KK, P(KK), SIGN(KK),
* (X(KK,NN),NN=2,14), ESN(KK),
* X(KK,16), X(KK,17), OP(KK)
110 WRITE (PRINTR,1400) P(2), SIGN(2), (X(2,NN), NN=2,14),
* ESN(2), X(2,16), X(2,17), OP(2),
* P(1), SIGN(1), (X(1,NN), NN=2,14),
* ESN(1), X(1,16), X(1,17), OP(1)
IF (SKIP2.EQ.0) WRITE (PRINTR,1500) DISP
120 WRITE (PRINTR,1600) DISP2
IF (SKIP2.EQ.3) RETURN
DO 140 II=2,4
IF (R(II,2).EQ.15) GO TO 140
DO 130 JJ=1,17
KK=R(II,JJ)
IF (KK.EQ.0) KK=10
130 REG(JJ)=CHAR(KK)
WRITE (PRINTR,1700) NAME(II-1), (REG(NN), NN=1,17)
140 CONTINUE
DO 160 II=5,20
IF (R(II,2).EQ.15) GO TO 160
JJ=II-5
DO 150 KK=1,17
LL=R(II,KK)
IF (LL.EQ.0) LL=10
150 REG(KK)=CHAR(LL)
WRITE (PRINTR,1800) JJ, (REG(NN), NN=1,17)
160 CONTINUE
DO 170 II=1,11
IF (UFLAG(II).EQ.1) GO TO 180
170 CONTINUE
RETURN
180 WRITE (PRINTR,1900) UFLAG
RETURN
1000 FORMAT (/6X, 'EXPRESSION: ', 20A3, (//19X, 20A3))
1100 FORMAT (//6X,'FLAGS: DP -',L2,20X,'INDICES: L -',
2 I2/14X,'EEX -',L2,30X,'M -',I2/14X,'FIXFLG-',
3 L2,30X,'FIX -',I2/14X,'NEXT -',L2,30X,'SCI -',
4 I2/14X,'STEPNO-',L2,30X,'ERROR -',I2)
1200 FORMAT (//6X, 'STACK: S(', I2, ') -', 4X, I2, ' / ', A2,
2 I2, ' .', 12I2, 1X, A2, 2I2, ' /', I3)
1300 FORMAT (14X, 'S(', I2, ') -', 4X, I2, ' / ', A2, I2, ' .',
2 12I2, 1X, A2, 2I2, ' /', I3)
1400 FORMAT (/14X, 'S( 2) -', 4X, I2, ' / ', A2, I2, ' .', 12I2,
2 1X, A2, 2I2, ' /', I3/14X, 'S( 1) -', 4X, I2, ' / ',
3 A2, I2, ' .', 12I2, 1X, A2, 2I2, ' /', I3/)
1500 FORMAT (2(/6X, 'DISPLAY:', 9X, 16A2))
1600 FORMAT (//6X, 'DISPLAY:', 9X, 16A2//)
1700 FORMAT (6X, A8, 2X, 2A2, '. ', 15A2)
1800 FORMAT (6X, 'R (', I2, ') =', 2X, 2A2, '. ', 15A2)
1900 FORMAT (/6X, 'USER FLAGS: ', I2, 2X, 5I2, 2X, 4I2, I4/)
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE CONTRL (START, PRINT)
C DATE OF LAST CHANGE - 750318
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, STEPNO
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
IF (NEXT) RETURN
GO TO (1, 2, 3, 6, 6), START
C ** START 1 - UPDATE & FORMAT "DISPLAY"
1 CALL UPDATE (1)
GO TO 5
C ** START 2 - FORMAT "DISPLAY"
2 CALL UPDATE (2)
GO TO 5
C ** START 3 - DASHES & KEY-CODE → "DISPLAY"
3 DSP(1)=15
DO 4 I=2,16
4 DSP(I)=13
DSP(8)=0
DSP(9)=CODE/10
DSP(10)=CODE-10*DSP(9)
5 IF (STEPNO) CALL STPNUM (2)
C ** START 4 - USE "DISPLAY" AS IS
6 CALL OUTIN (PRINT)
IF (CODE.NE.30) GO TO 7
CALL LSTKEY
IF (.NOT.NEXT) GO TO 6
NEXT=.FALSE.
7 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE OUTIN (PRINT)
C DATE OF LAST CHANGE - 750714
IMPLICIT INTEGER (A-Z)
LOGICAL STEPNO, DECODE
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /OUTPT/ SKIP, DISPLY(32), PGMPTR, READER, PRINTR
CALL OUTPUT (PRINT)
LSTK=CODE
1 IF (.NOT.DECODE) GO TO 2
CALL DCODER (CODE)
IF (CODE.LT.100) GO TO 3
CALL OUTPUT (CODE-100)
GO TO 1
2 WRITE (PRINTR,4)
READ (READER,5) CODE
IF (CODE.NE.15) GO TO 3
CALL OUTPUT (2)
GO TO 2
3 KEY=KEY+1
EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
IF (STEPNO) PGMPTR=PGMPTR+1
RETURN
4 FORMAT (/' NN?')
5 FORMAT (I2)
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE DCODER (CODE)
C DATE OF LAST CHANGE - 760201
IMPLICIT INTEGER (A-Z)
DIMENSION KEYS (90)
COMMON /OUTPT/ SKIP, DISPLY(32), PGMPTR, READER, PRINTR
DATA KEYS /'1 ','2 ','3 ','4 ','5 ','6 ','7 ','8 ','9 ','0 ',
1 '. ','E ','- ','+ ',' ','/ ','* ','( ','**',') ',
2 'RR','= ','A ','PI','R ','CL','CD','CO','DR','LK',
3 'ST','FX','SI','IX','XC','; ',', ','LX','LY','EQ',
4 'NE','GT','LT','MG','AG','AB','SR','SQ','MX','SC',
5 'FL','KL','LS','U ',') ','XX','= ','A ','P ','R ',
6 'C ','D ','O ','V ','L ','Z ','J ','N ','I ','H ',
7 '; ',', ','X ','Y ','? ','# ','> ','< ','M ','G ',
8 'B ','T ','Q ','W ','S ','F ','K ',': ','SS','RS'/
DATA MAXKEY /90/
1 WRITE (PRINTR,4)
READ (READER,5) KEY
DO 2 I=1,MAXKEY
IF (KEY.EQ.KEYS(I)) GO TO 3
2 CONTINUE
WRITE (PRINTR,6) KEY
GO TO 1
3 CODE=I
IF (CODE.GT.53) CODE=CODE-35
IF (CODE.EQ.15) CODE=102
IF (CODE.EQ.21) CODE=98
IF (CODE.LT.53) RETURN
IF (CODE.EQ.53) CODE=100
IF (CODE.EQ.54) CODE=101
IF (CODE.EQ.55) CODE=99
C CODE = 98 -> TERMINATE EXECUTION
C CODE = 99 -> RESTART EXECUTION
C CODE = 100 + N -> "CALL OUTPUT (N)" UPON RETURN TO "OUTIN"
RETURN
4 FORMAT (//' AA?'/)
5 FORMAT (A2)
6 FORMAT (' "', A2, '" IS NOT A VALID CODE'/)
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE STPNUM (START)
C DATE OF LAST CHANGE - 741231
IMPLICIT INTEGER (A-Z)
LOGICAL STEPNO
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /OUTPT/ SKIP, DISPLY(32), PGMPTR, READER, PRINTR
II=START+1
GO TO (1, 2, 3), II
C ** START 0 - COMPLEMENT "STEPNO"
1 STEPNO=.NOT.STEPNO
RETURN
C ** START 1 - DISPLAY PROGRAM POINTER?
2 IF (.NOT.STEPNO) RETURN
C ** START 2 - DISPLAY PROGRAM POINTER!
3 DSP(1)=PGMPTR/1000
DSP(2)=PGMPTR/100-10*DSP(1)
DSP(3)=PGMPTR/10-100*DSP(1) -10*DSP(2)
DSP(4)=PGMPTR/1-1000*DSP(1)-100*DSP(2)-10*DSP(3)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE UPDATE (START)
C DATE OF LAST CHANGE - 750801
C PURPOSE: 1 - COPY X(1) TO D USING CURRENT DISPLAY FORMAT
C (W CONTAINS X(1) ROUNDED TO RIGHT NO. OF DIGITS)
C 2A - COPY D TO DSP INSERTING SPACING BLANKS
C 2B - COPY DSP TO DSP RIGHT JUSTIFYING MANTISSA
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG, STEPNO
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /OUTPT/ SKIP, DISPLY(32), PGMPTR, READER, PRINTR
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (START.EQ.2) GO TO 20
C ** DISPLAY PARENTHESES, MAYBE
IF (P(1).EQ.0) GO TO 2
IF (X(1,2).NE.15) GO TO 2
IF (X(1,1).NE.15) GO TO 2
DO 1 I=1,16
1 DSP(I)=15
I=1
IF (STEPNO) I=6
DSP(I)=P(1)/10
DSP(I+1)=P(1)-10*DSP(I)
IF (DSP(I).EQ.0) DSP(I)=15
DSP(I+2)=13
RETURN
C ** START1 - UPDATE DISPLAY CONTENTS
2 IF (OP(1).GE.70) GO TO 20
IF (.NOT.FIXFLG) GO TO 10
C DISPLAY IN "FIX" FORMAT, IF POSSIBLE
IF (X(1,16).GT.0 .AND. X(1,15).NE.13) GO TO 10
N=FIX
K=FIX+1
KMAX=10*X(1,16)+X(1,17)
IF (X(1,15).NE.13) GO TO 3
K=K-KMAX
IF (K.GE.0) GO TO 4
K=N+2
GO TO 6
3 K=K+KMAX
IF (K.LE.10) GO TO 4
N=9-KMAX
K=10
4 CALL ROUND
IF (W(16).GT.0 .AND. W(15).NE.13) GO TO 10
K=10*W(16)+W(17)+1
IF (W(15).EQ.13) GO TO 6
DO 5 I=1,K
5 D(I+1)=W(I+1)
J=K
K=K+1
KMAX=K+N
D(K+1)=11
GO TO 8
6 D(2)=0
D(3)=11
DO 7 I=3,K
7 D(I+1)=0
J=0
KMAX=N+2
8 K=K+1
IF (K.GT.KMAX) GO TO 9
J=J+1
D(K+1)=W(J+1)
GO TO 8
9 KMAX=15
GO TO 16
C DISPLAY IN "SCI" FORMAT
10 IF (.NOT.STEPNO) GO TO 11
IF (SCI.LT.7) GO TO 11
N=6
GO TO 12
11 N=SCI
12 K=N
CALL ROUND
D(2)=W(2)
D(3)=11
IF (W(15).NE.42) GO TO 13
IF (.NOT.STEPNO) N=10
IF (STEPNO) N=6
W(15)=15
13 DO 14 I=2,N
14 D(I+2)=W(I+1)
D(13)=12
DO 15 I=13,15
15 D(I+1)=W(I+2)
K=N+2
IF (K.GT.11) GO TO 18
KMAX=11
16 DO 17 I=K,KMAX
17 D(I+1)=15
C X(1) = 0 ?
18 IF (X(1,2).NE.0) GO TO 20
DO 19 I=2,12
IF (D(I).NE.11) GO TO 19
D(I)=15
GO TO 20
19 CONTINUE
C ** START 2 - FORMAT DISPLAY CONTENTS
20 DO 21 II=1,16
DSP(II)=15
21 DISPLY(II)=D(II)
DSP(1)=X(1,1)
C DISPLAY FUNCTION?
IF (OP(1).LT.70) GO TO 22
DSP(3)=11
DSP(4)=0
DSP(5)=X(1,2)/10
DSP(6)=X(1,2)-10*DSP(5)
DSP(7)=11
DSP(8)=X(1,3)
IF (X(1,3).EQ.X(1,4)) GO TO 36
DSP(9)=13
DSP(10)=X(1,4)
GO TO 36
C X(1) = "NULL" ?
22 IF (X(1,2).NE.15) GO TO 23
IF (M.EQ.1) GO TO 36
C DISPLAY PROGRAM POINTER?
23 IF (STEPNO) GO TO 33
C COPY D TO DSP, INSERTING SPACING BLANKS
I=1
K=0
J=0
N=0
24 N=N+1
IF (D(N+1).GT.9) GO TO 25
K=K+1
IF (K.NE.3) GO TO 24
K=0
J=J+1
GO TO 24
25 N=1
26 IF (K.EQ.0) GO TO 28
IF (D(N+1).GT.11) GO TO 31
27 IF (I.GT.15) GO TO 33
DSP(I+1)=D(N+1)
I=I+1
N=N+1
K=K-1
GO TO 26
28 IF (J.EQ.0) GO TO 30
IF (I.EQ.1) GO TO 29
IF (I.EQ.16) GO TO 29
DSP(I+1)=15
I=I+1
29 K=3
J=J-1
GO TO 26
30 IF (D(N+1).EQ.12) GO TO 32
K=4
J=10
GO TO 27
31 IF (D(13).NE.12) GO TO 36
32 K=13
IF (I.LT.13) GO TO 34
33 K=2
34 DO 35 II=K,16
35 DSP(II)=D(II)
IF (DSP(13).NE.12) GO TO 36
IF (DSP(15).NE.0) GO TO 36
DSP(15)=DSP(16)
DSP(16)=15
C
36 DO 37 II=1,16
37 DISPLY(II+16)=DSP(II)
C
C COPY DSP TO DSP, RIGHT JUSTIFYING MANTISSA
K=11
38 IF (DSP(K+1).NE.15) GO TO 39
IF (K.EQ.0) RETURN
K=K-1
GO TO 38
39 IF (.NOT.STEPNO) GO TO 41
IF (DSP(13).NE.12) GO TO 40
N=11
IF (K.GT.7) K=7
GO TO 42
40 N=15
GO TO 42
41 IF (K.GT.9) RETURN
N=10
IF (DSP(9).EQ.13) N=12
42 DSP(N+1)=DSP(K+1)
IF (K.EQ.0) GO TO 43
N=N-1
K=K-1
GO TO 42
43 DO 44 I=1,N
44 DSP(I)=15
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE MESAGE (TYPE, ERR, RTRN)
C DATE OF LAST CHANGE - 751116
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, RUNPGM, STEPNO, TEMPF, TEMPF2
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DATA RUNPGM /.FALSE./
RTRN=0
GO TO (5, 5, 5, 1, 2, 3, 3), TYPE
1 IF (CODE.EQ.28) GO TO 20
IF (CODE.EQ.27) GO TO 20
IF (CODE.EQ.26) GO TO 19
GO TO 5
2 TEMPF2=NEXT
3 UFLAG(11)=1
IF (UFLAG(10).NE.1) GO TO 5
C SAVE ERROR CODE & RETURN FOR STANDARD FIXUP
ERROR=0
DO 4 I=2,10
IF (R(20,I).NE.15) GO TO 4
R(20,I)=ERR/10
R(20,I+1)=ERR-10*R(20,I)
R(20,I+2)=13
R(20,15)=42
RETURN
4 CONTINUE
RETURN
C DISPLAY ERROR
5 ERROR=ERR
NEXT=.FALSE.
DO 6 I=1,16
6 DSP(I)=15
C KEYBOARD ERROR MESSAGE → "DSP"
DSP(4)=12
DO 7 I=5,8
7 DSP(I)=25
DSP(7)=21
DSP(10)=ERROR/10
DSP(11)=11
DSP(12)=ERROR-10*DSP(10)
IF (TYPE.GT.3) DSP(14)=25
C MODIFY MESSAGE FOR PROGRAM ERROR, MAYBE
IF (RUNPGM) GO TO 8
IF (.NOT.STEPNO) GO TO 10
8 J=13
K=15
9 DSP(K+1)=DSP(J+1)
J=J-1
K=K-1
IF (J.GT.2) GO TO 9
DSP(5)=15
CALL STPNUM (2)
10 ERROR=0
C LOOK FOR AND ACT ACCORDING TO USER'S RESPONSE
I=LSTK
J=CODE
11 CALL CONTRL (5, 3)
IF (CODE.NE.28) GO TO 16
CODE=I
GO TO (13, 20, 20, 13, 15, 14, 12), TYPE
12 TEMPF=.TRUE.
13 RTRN=0
RETURN
14 IF (OP(1).NE.0) OP(1)=0
15 CODE=-1
GO TO 20
16 IF (CODE.NE.27) GO TO 18
CODE=I
GO TO (13, 20, 15, 15, 17, 17, 17), TYPE
17 RTRN=0
CODE=J
IF (TYPE.EQ.5) NEXT=TEMPF2
RETURN
18 IF (CODE.NE.26) GO TO 11
19 NEXT=.TRUE.
20 RTRN=1
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE FIXN
C DATE OF LAST CHANGE - 741108
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
FIXFLG=.TRUE.
LFRC=0
CALL NUMBER (1, RTRN)
IF (RTRN.EQ.1) GO TO 1
FIX=W(2)
1 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE SCIN
C DATE OF LAST CHANGE - 741108
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
FIXFLG=.FALSE.
LFRC=0
CALL NUMBER (1, RTRN)
IF (RTRN.EQ.1) GO TO 1
SCI=W(2)+1
1 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE RESET
C DATE OF LAST CHANGE - 741024
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
L=1
M=1
DP=.FALSE.
EEX=.FALSE.
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE CLEAR
C DATE OF LAST CHANGE - 740920
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
CALL CLEARX (3)
DO 1 I=2,SMAX
J=I-1
P(I)=P(J)
OP(I)=OP(J)
DO 1 K=1,17
1 X(I,K)=X(J,K)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE LPAREN
C DATE OF LAST CHANGE - 750616
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
TEMPF=.FALSE.
IF (X(1,2).NE.15) GO TO 2
IF (X(1,1).EQ.13) GO TO 1
IF (P(1).NE.15) GO TO 3
CALL MESAGE (2, 92, RTRN)
RETURN
1 CALL TESTUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
X(1,2)=1
TEMPF=.TRUE.
2 CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
IF (.NOT.TEMPF) GO TO 3
IF (OP(2).EQ.50) OP(2)=51
3 P(1)=P(1)+1
4 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE RPAREN (START)
C DATE OF LAST CHANGE - 750716
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (START.EQ.2) GO TO 11
C ** START 1 - NORMAL ENTRY FOR ")"
IF (OP(1).LT.2) GO TO 2
1 CALL MESAGE (2, 11, RTRN)
RETURN
2 DO 3 I=1,SMAX
IF (P(I).NE.0) GO TO 4
3 CONTINUE
CALL MESAGE (2, 21, RTRN)
RETURN
4 IF (P(I).NE.1) GO TO 7
IF (OP(I+1).LT.72) GO TO 7
K=1
IF (I.EQ.1) GO TO 6
J=I
5 IF (OP(J).NE.10) GO TO 6
K=K+1
J=J-1
IF (J.NE.1) GO TO 5
6 IF (X(I+1,3).LE.K) GO TO 7
CALL MESAGE (2, 53, RTRN)
RETURN
7 IF (P(1).NE.0) GO TO 10
IF (X(1,2).EQ.15) GO TO 1
IF (OP(2).EQ.10) GO TO 8
PTR=2
CALL EXECUT (1, RTRN)
IF (RTRN.EQ.1) GO TO 14
GO TO 7
8 DO 9 I=3,SMAX
IF (OP(I).LT.72) GO TO 9
PTR=I
CALL EXECUT (1, RTRN)
IF (RTRN.EQ.1) GO TO 14
RETURN
9 CONTINUE
CALL MESAGE (2, 36, RTRN)
RETURN
10 IF (X(1,2).NE.15) GO TO 11
CALL MESAGE (6, 23, RTRN)
IF (RTRN.EQ.1) GO TO 14
C ** START 2 - ENTRY FROM CORRECT TO REMOVE A "("
11 P(1)=P(1)-1
IF (P(1).NE.0) RETURN
IF (X(1,2).NE.15) GO TO 13
C HERE TO STATEMENT 13 FIXES UP "()"
IF (OP(2)/10.NE.5) GO TO 12
IF (OP(2).EQ.51) X(2,2)=15
OP(2)=0
12 CALL DROP (1)
IF (OP(1).LT.71) RETURN
IF (OP(1).EQ.72) RETURN
CALL ARGMNT (4, RTRN)
RETURN
13 IF (OP(2).LT.70) RETURN
PTR=2
CALL EXECUT (2, RTRN)
14 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE EQUAL
C DATE OF LAST CHANGE - 741024
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (X(1,2).EQ.15) GO TO 1
IF (OP(1).LT.10) GO TO 2
1 CALL MESAGE (2, 11, RTRN)
RETURN
2 DO 3 I=1,SMAX
IF (P(I).EQ.0) GO TO 3
CALL MESAGE (2, 22, RTRN)
RETURN
3 CONTINUE
4 IF (OP(2).EQ.0) GO TO 5
PTR=2
CALL EXECUT (1, RTRN)
IF (RTRN.EQ.1) GO TO 6
GO TO 4
5 OP(1)=1
C- RN="RESULT-REGISTER NUMBER"
C- CALL TRANS (.TRUE.)
6 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE EXCH
C DATE OF LAST CHANGE - 750416
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DO 1 I=1,17
1 W(I)=X(1,I)
DO 2 I=1,17
2 X(1,I)=X(2,I)
DO 3 I=1,17
3 X(2,I)=W(I)
IF (OP(1).GT.60) GO TO 4
IF (OP(2).LT.70) GO TO 5
4 W(1)=OP(1)
OP(1)=OP(2)
OP(2)=W(1)
5 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE DRPSTK
C DATE OF LAST CHANGE - 750220
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
IF (OP(1).EQ.0) GO TO 2
1 CALL MESAGE (2, 16, RTRN)
RETURN
2 IF (X(1,2).NE.15) GO TO 1
IF (P(1).NE.0) GO TO 1
IF (OP(2).EQ.50) OP(2)=0
CALL DROP (1)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE SIGN
C DATE OF LAST CHANGE - 750416
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
IF (OP(1).NE.0) GO TO 2
IF (X(1,2).EQ.15) GO TO 5
1 OP(1)=CODE+17
CALL COLAPS (RTRN)
IF (RTRN.EQ.1) GO TO 6
RETURN
2 IF (OP(1).EQ.1) GO TO 1
IF (OP(1).LT.72) GO TO 3
CALL MESAGE (1, 52, RTRN)
RETURN
3 IF (X(SMAX,2).EQ.15) GO TO 4
CALL MESAGE (2, 91, RTRN)
RETURN
4 CALL ENTRUP
5 IF (CODE.NE.13) GO TO 6
IF (X(1,1).EQ.13) D(1)=15
IF (X(1,1).NE.13) D(1)=13
X(1,1)=D(1)
6 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE OPRATR
C DATE OF LAST CHANGE - 740925
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
IF (X(1,2).EQ.15) GO TO 1
IF (OP(1).LT.10) GO TO 2
1 CALL MESAGE (2, 12, RTRN)
RETURN
2 IF (CODE.LT.19) OP(1)=CODE+24
IF (CODE.EQ.19) OP(1)=60
IF (CODE.EQ.36) OP(1)=10
IF (CODE.EQ.37) OP(1)=10
IF (CODE.GT.37) OP(1)=CODE-20
CALL COLAPS (RTRN)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE FUNCTN (START)
C DATE OF LAST CHANGE - 750612
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
* /MISC3/ CNT, TMP, S(17), T(17)
GO TO ( 1, 2, 3, 9, 13), START
C ** START 1 - MULTIPLE ARGUMENT FUNCTION
1 TMP=2
TEMP=2
IF (CODE.EQ.49) TEMP=6
C ** START 2 - VARIABLE ARGUMENT M.A.F. (TMP & TEMP ALREADY SET)
2 NEXT=.TRUE.
GO TO 4
C ** START 3 - SINGLE ARGUMENT FUNCTION
3 TMP=1
TEMP=1
NEXT =.FALSE.
4 TEMPF=.FALSE.
5 CALL FTSTUP (RTRN)
IF (RTRN.EQ.1) GO TO 12
X(1,2)=CODE
X(1,3)=TMP
X(1,4)=TEMP
D(1)=15
IF (TEMPF) GO TO 14
IF (NEXT) GO TO 6
OP(1)=70
RETURN
C CONTINUE MULTIPLE ARGUMENT FUNCTION
6 OP(1)=72
7 NEXT=.FALSE.
CALL CONTRL (2, 3)
NEXT=.TRUE.
IF (CODE.EQ.18) RETURN
IF (CODE.EQ.34) RETURN
IF (CODE.GT.28) GO TO 8
IF (CODE.GT.25) RETURN
8 CALL MESAGE (1, 52, RTRN)
IF (RTRN.EQ.1) GO TO 12
GO TO 7
C ** START 4 - "IMMEDIATE" SINGLE ARGUMENT FUNCTION
9 IF (X(1,2).EQ.15) GO TO 10
IF (OP(1).LT.2) GO TO 11
10 CALL MESAGE (2, 12, RTRN)
RETURN
11 OP(1)=70
CALL COLAPS (RTRN)
IF (RTRN.EQ.1) GO TO 12
OP(1)=0
PTR=0
CALL EXECUT (2, RTRN)
12 RETURN
C ** START 5 - "LANGUAGE FUNCTION"
13 TEMPF=.TRUE.
GO TO 5
14 IF (TEMP.EQ.1) GO TO 15
OP(1)=73
X(1,5)=OPCD
GO TO 16
15 OP(1)=71
16 CODE=18
IF (OP(2).NE.50) GO TO 17
IF (P(1).EQ.0) OP(2)=0
17 CALL LPAREN
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE COMMA
C DATE OF LAST CHANGE - 760205
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DO 1 I=2,SMAX
IF (OP(I).GT.71) GO TO 2
1 CONTINUE
C TREAT AS "NO-OP"
RETURN
C TREAT AS ARGUMENT SEPARATOR FOR "M.A.F."
2 J=I-1
IF (P(J).EQ.1) GO TO 4
3 CALL MESAGE (2, 22, RTRN)
RETURN
4 K=1
5 IF (J.EQ.1) GO TO 6
IF (OP(J).EQ.10) K=K+1
J=J-1
IF (P(J).NE.0) GO TO 3
GO TO 5
6 IF (X(I,4).GT.K) GO TO 7
CALL MESAGE (2, 54, RTRN)
RETURN
7 CALL OPRATR
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE IMEDEX
C DATE OF LAST CHANGE - 750608
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (X(1,2).EQ.15) GO TO 1
IF (X(2,2).EQ.15) GO TO 1
IF (P(1).EQ.0) GO TO 2
1 CALL MESAGE (2, 15, RTRN)
RETURN
C- FOLLOWING 5 LINES ARE BASED ON M.A.F.'S CALLING "LPAREN"
C- 2 IF (OP(2).LT.72) GO TO 4
C- IF (OP(1).NE.0) GO TO 1
C- CALL DROP (1)
C- FOLLOWING LINE NOT USED WHEN M.A.F.'S CALL "LPAREN"
2 IF (OP(1).LT.72) GO TO 4
IF (X(3,2).EQ.15) GO TO 1
OP(3)=OP(1)
OP(1)=0
DO 3 I=1,17
TEMP=X(1,I)
X(1,I)=X(2,I)
X(2,I)=X(3,I)
3 X(3,I)=TEMP
PTR=3
GO TO 9
4 IF (OP(1).LT.20) GO TO 8
IF (OP(2).LT.20) GO TO 5
IF (OP(2).NE.50) GO TO 1
5 IF (OP(1).NE.70) GO TO 6
CALL EXCH
GO TO 7
6 OP(2)=OP(1)
7 OP(1)=0
PTR=2
GO TO 9
8 IF (OP(2).LT.20) GO TO 1
9 CALL EXECUT (1, RTRN)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE COLAPS (RTRN)
C DATE OF LAST CHANGE - 760201
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
1 IF (P(1).NE.0) RETURN
IF (OP(2).LT.20) RETURN
IF (OP(1)/10 .GT. OP(2)/10) RETURN
IF (OP(1).GE.70) RETURN
PTR=2
CALL EXECUT (1, RTRN)
IF (RTRN.EQ.1) GO TO 2
GO TO 1
2 RTRN=1
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE EXECUT (START, RTRN)
C DATE OF LAST CHANGE - 741218
IMPLICIT INTEGER (A-Z)
DIMENSION A(6,17)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DATA A/34*0,68*0/
RTRN=0
IF (START.EQ.2) GO TO 4
C ** START 1 - BINARY OPERATORS & MULTIPLE ARGUMENT FUNCTIONS
IF (OP(2).EQ.70) GO TO 6
C SAVE X(2,N) IN "LST X" & X(1,N) IN "LST Y"
DO 1 J=1,17
R(4,J)=X(1,J)
R(3,J)=X(2,J)
DO 1 I=1,2
1 A(I,J)=X(I,J)
IF (OP(PTR).GT.71) GO TO 3
C EXECUTE BINARY FUNCTION
OPCD=OP(2)
CALL COMBIN (A, 2, 0, RTRN)
IF (RTRN.EQ.1) GO TO 14
DO 2 J=1,17
2 X(1,J)=A(1,J)
GO TO 12
C EXECUTE "M.A.F."
3 IF (OP(PTR).EQ.73) GO TO 5
OPCD=OP(PTR)+X(PTR,2)
CALL COMBIN (A, 2, 0, RTRN)
IF (RTRN.EQ.1) GO TO 14
GO TO 10
C ** START 2 - SINGLE ARGUMENT FUNCTIONS
4 IF (OP(2).LT.71) GO TO 6
5 CALL ARGMNT (3, RTRN)
RETURN
C SAVE X(1,N) IN "LST X"; EXECUTE "S.A.F."
6 RN=-2
CALL TRANS (.TRUE.)
DO 7 J=1,17
7 A(1,J)=X(1,J)
IF (PTR.NE.0) GO TO 8
OPCD=70+CODE
GO TO 9
8 OPCD=OP(2)+X(2,2)
9 CALL COMBIN (A, 1, 0, RTRN)
IF (RTRN.EQ.1) GO TO 14
10 DO 11 J=1,17
11 X(1,J)=A(1,J)
IF (PTR.EQ.0) GO TO 13
C CONSIDER SIGN PRECEEDING FUNCTION
IF (X(PTR,1).NE.13) GO TO 12
SIGN=X(1,1)
IF (SIGN.EQ.13) X(1,1)=15
IF (SIGN.NE.13) X(1,1)=13
C DROP STACK APPROPRIATE AMOUNT
12 CALL DROP (2)
IF (PTR.LT.3) GO TO 13
PTR=PTR-1
GO TO 12
C CHECK FOR "-0"
13 IF (X(1,2).EQ.0) X(1,1)=15
14 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE COMBIN (A, NARGS, ESHIFT, RTRN)
C DATE OF LAST CHANGE - 750701
C PURPOSE: EXECUTE- "A(2,N) OPCD A(1,N) → A(1,N)"
C "SAF A(1,N) → A(1,N)"
C "A(2,N) SAF → A(1,N)"
C "MAF (A(2,N) ;|, A(1,N)) → A(1,N)"
IMPLICIT INTEGER (A-Z)
DOUBLE PRECISION RX, DABS, DATAN, DLOG10, DMAX1
DIMENSION A(6,17), EXP(6), RX(6)
COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
C (1) CONVERT A(I,N) TO RX(I)
II=2
IF (OPCD.EQ.121) II=PTR-1
DO 2 I=1,II
RX(I)=A(I,14)
DO 1 J=1,12
KK=14-J
1 RX(I)=0.1*RX(I)+A(I,KK)
IF (A(I,1).EQ.13) RX(I)=-RX(I)
EXP(I)=10*A(I,16)+A(I,17)
IF (A(I,15).EQ.13) EXP(I)=-EXP(I)
2 CONTINUE
C (2) NOW EXECUTE RX(2), OPCD, RX(1) -> RX(1)=RX1
IF (OPCD.GT.60) GO TO 22
IF (OPCD.EQ.60) GO TO 14
IF (OPCD.GT.31) GO TO 10
IF (OPCD.GT.23) GO TO 9
IF (OPCD.GT.10) GO TO 3
CALL MESAGE (2, 38, RTRN)
RETURN
C RELATIONALS
3 VALUE=0
RX(1)=-RX(1)
CALL ADD (RX, EXP)
OPCD=OPCD-19
GO TO (4, 5, 6, 7), OPCD
4 IF (RX(1) .EQ. 0.0) VALUE=1
GO TO 8
5 IF (RX(1) .NE. 0.0) VALUE=1
GO TO 8
6 IF (RX(1) .GT. 0.0) VALUE=1
GO TO 8
7 IF (RX(1) .LT. 0.0) VALUE=1
8 RX(1)=VALUE
GO TO 36
C ADDITION/SUBTRACTION
9 IF (OPCD.EQ.30) RX(1)=-RX(1)
CALL ADD (RX, EXP)
GO TO 36
C MULTIPLICATION/DIVISION
10 IF (OPCD.EQ.40) GO TO 11
RX(1)=RX(2)*RX(1)
EXP(1)=EXP(2)+EXP(1)
GO TO 36
11 IF (RX(1).NE.0.0) GO TO 13
ERROR=31
JJ=A(2,1)
12 KK=9
C- "EXP OF A"="+ OVERFLOW"
J=42
GO TO 42
13 RX(1)=RX(2)/RX(1)
EXP(1)=EXP(2)-EXP(1)
GO TO 36
C EXPONENTIATION
14 IF (RX(2)) 15, 16, 17
15 CALL MESAGE (6, 32, RTRN)
IF (RTRN.EQ.1) GO TO 49
RX(2)=-RX(2)
GO TO 17
16 RX(1)=0.0
EXP(1)=0
GO TO 36
17 RX(2)=RX(1)*(DLOG10(RX(2))+EXP(2))
S=1
IF (RX(2)) 18, 19, 20
18 RX(2)=-RX(2)
S=-1
GO TO 20
19 RX(1)=1.0
EXP(1)=0
GO TO 36
20 RX(2)=DLOG10(RX(2))
EXP(2)=RX(2)
RX(2)=10.0**(RX(2)-EXP(2))
EXP(2)=EXP(1)+EXP(2)
IF (EXP(2).LT.2) GO TO 21
ERROR=34+ESHIFT
JJ=15
GO TO 12
21 RX(2)=S*RX(2)*10.0**EXP(2)
EXP(1)=RX(2)
RX(1)=10.0**(RX(2)-EXP(1))
GO TO 36
C SINGLE ARGUMENT FUNCTIONS
22 OPCD=OPCD-115
IF (NARGS.NE.1) GO TO 27
GO TO (23, 24, 26), OPCD
C "ABS (X)"
23 RX(1)=DABS(RX(1))
GO TO 36
C "SQRT (X)"
24 IF (RX(1).GT.0) GO TO 25
ERROR=32
RX(1)=-RX(1)
25 CALL MYSQRT(RX(1), EXP(1))
GO TO 36
C "(X)**2"
26 RX(1)=RX(1)*RX(1)
EXP(1)=EXP(1)+EXP(1)
GO TO 36
C MULTIPLE ARGUMENT FUNCTIONS
27 GO TO (28, 32), OPCD
C "MAX (X, Y, ...)"
IF (PTR.EQ.3) RX(1)=DMAX1(RX(1), RX(2))
IF (PTR.EQ.4) RX(1)=DMAX1(RX(1), RX(2), RX(3))
IF (PTR.EQ.5) RX(1)=DMAX1(RX(1), RX(2), RX(3), RX(4))
IF (PTR.EQ.6) RX(1)=DMAX1(RX(1), RX(2), RX(3), RX(4),
* RX(5))
IF (PTR.EQ.7) RX(1)=DMAX1(RX(1), RX(2), RX(3), RX(4),
* RX(5), RX(6))
GO TO 36
C "MAG (X,Y)"
28 KK=EXP(2)-EXP(1)
IF (IABS(KK).LT.15) GO TO 30
IF (KK) 36, 30, 29
29 RX(1)=RX(2)
EXP(1)=EXP(2)
GO TO 36
30 DO 31 I=1,2
31 RX(I)=RX(I)*RX(I)
EXP(2)=KK*2
KK=EXP(1)
EXP(1)=0
CALL ADD (RX, EXP)
CALL MYSQRT (RX(1), EXP(1))
EXP(1)=EXP(1)+KK
GO TO 36
C "ARG (X,Y)"
32 IF (RX(2).NE.0.0) GO TO 34
33 RX(1)=9.0
EXP(1)=1
GO TO 36
34 EXP(2)=EXP(1)-EXP(2)
IF (EXP(2).GT.30) GO TO 33
EXP(1)=0
IF (EXP(2).GT.-30) GO TO 35
RX(1)=0.0
GO TO 36
35 RX(1)=DATAN((RX(1)/RX(2))*10.0**EXP(2))*57.29577951D0
C (3) EXTRACT EXPONENT, -> A(1,15), ..., A(1,17)
36 IF (RX(1).NE.0.0) GO TO 37
KK=0
GO TO 39
37 IF (DABS(RX(1)).GE.1.0) GO TO 38
RX(1)=RX(1)*10.0
EXP(1)=EXP(1)-1
GO TO 37
38 IF (DABS(RX(1)).LT.10.0) GO TO 39
RX(1)=RX(1)/10.0
EXP(1)=EXP(1)+1
GO TO 38
39 IF (EXP(1).GE.0) GO TO 40
EXP(1)=-EXP(1)
A(1,15)=13
GO TO 41
40 A(1,15)=15
41 A(1,16)=EXP(1)/10
A(1,17)=EXP(1)-10*A(1,16)
C (4) CHECK FOR OVER/UNDER-FLOW
IF (A(1,16).LT.10) GO TO 44
ERROR=34+ESHIFT
JJ=14+RX(1)/DABS(RX(1))
IF (A(1,15).NE.13) GO TO 12
ERROR=33+ESHIFT
KK=0
JJ=15
C- "EXP OF A"="+"
J=15
42 A(1,1)=JJ
DO 43 I=2,17
43 A(1,I)=KK
A(1,15)=J
GO TO 48
C (5) CONVERT RX(1) TO A(1,N), N=1, ..., 14
44 IF (RX(1).GE.0.0) GO TO 45
A(1,1)=13
RX(1)=-RX(1)
GO TO 46
45 A(1,1)=15
46 A(1,2)=RX(1)
DO 47 I=3,14
J=I-1
RX(1)=10.*(RX(1)-A(1,J))
47 A(1,I)=RX(1)
48 ERR=ERROR
IF (ERROR.NE.0) CALL MESAGE (6, ERR, RTRN)
49 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE ADD (X, K)
C DATE OF LAST CHANGE - 750701
C PURPOSE: ADD TOGETHER TWO NUMBERS IN SCIENTIFIC NOTATION
DOUBLE PRECISION X, DABS, DLOG10
DIMENSION X(2), K(2)
J=K(1)-K(2)
IF (J.LT.15) GO TO 1
X(2)=0.0
GO TO 3
1 IF (J.GT.-15) GO TO 2
X(1)=0.0
K(1)=K(2)
GO TO 3
2 X(1)=X(1)*10.0**J
K(1)=K(1)-J
3 X(1)=X(1)+X(2)
IF (X(1).NE.0.0) GO TO 4
K(1)=0
GO TO 6
4 IF (DABS(X(1)).GE.1.0) GO TO 5
X(1)=X(1)*10.0
K(1)=K(1)-1
GO TO 4
5 KK=DLOG10(DABS(X(1)))+0.00001
X(1)=X(1)/10.0**KK
K(1)=K(1)+KK
6 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE MYSQRT (X, K)
C DATE OF LAST CHANGE - 750701
C PURPOSE: TAKE SQUARE ROOT OF NUMBER IN SCIENTIFIC NOTATION
DOUBLE PRECISION X, DSQRT
IF (2*(K/2).EQ.K) GO TO 1
K=K-1
X=X*10.0
1 X=DSQRT (X)
K=K/2
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE ENTRY
C DATE OF LAST CHANGE - 750628
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, NEXT, TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 11
DO 1 I=2,16
1 D(I)=15
2 IF (CODE.GT.9) GO TO 3
CALL DIGIT
GO TO 12
3 IF (CODE.NE.11) GO TO 4
CALL DECPT
GO TO 12
4 IF (CODE.NE.12) GO TO 5
CALL ENTEXP
IF (ERROR.NE.0) RETURN
GO TO 12
5 IF (CODE.NE.28) GO TO 6
CALL CORECT (1)
IF (.NOT.TEMPF) GO TO 12
RETURN
6 IF (.NOT.EEX) GO TO 7
IF (CODE.NE.13 .AND. CODE.NE.14) GO TO 7
IF (D(15).NE.0) GO TO 7
IF (D(16).NE.15) GO TO 7
D(14)=CODE
IF (D(14).EQ.14) D(14)=15
GO TO 12
7 IF (X(1,2).EQ.15) GO TO 8
IF (D(13).NE.12) GO TO 9
IF (CODE.EQ.26) GO TO 10
IF (CODE.EQ.27) GO TO 10
CALL ADEXPD (RTRN)
IF (RTRN.EQ.1) GO TO 11
IF (TEMPF) GO TO 12
GO TO 9
8 X(1,2)=0
9 CALL RESET
10 NEXT=.TRUE.
11 RETURN
C FORMAT "DISPLAY" & GET NEXT KEYSTROKE
12 CALL CONTRL (2, 3)
GO TO 2
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE DIGIT
C DATE OF LAST CHANGE - 750714
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
IF (.NOT.EEX) GO TO 1
D(15)=D(16)
IF (D(15).EQ.15) D(15)=0
D(16)=CODE
RETURN
1 IF (L.EQ.14) RETURN
IF (M.EQ.16) RETURN
IF (D(13).NE.12) GO TO 2
IF (M.GT.11) RETURN
2 M=M+1
D(M)=CODE
IF (DP) GO TO 3
IF (L.EQ.1) GO TO 4
CALL EXPON (X(1,15), X(1,16), X(1,17), 1)
GO TO 5
3 IF (L.NE.1) GO TO 5
CALL EXPON (X(1,15), X(1,16), X(1,17), -1)
4 IF (CODE.EQ.0) RETURN
5 L=L+1
X(1,L)=CODE
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE CLEARX (START)
C DATE OF LAST CHANGE - 760205
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 2, 3, 4, 5), START
C ** START 1 - "CLEAR X"
1 OP(1)=0
C ** START 2 - CLEAR X(1) & DROP X(2), ... MAYBE
2 IF (OP(2).LT.50) GO TO 4
IF (OP(2).EQ.60) GO TO 4
IF (P(1).NE.0) GO TO 4
IF (OP(2).LT.70) OP(2)=0
CALL DROP (1)
RETURN
C ** START 3 - CLEAR S(1)
3 P(1)=0
OP(1)=0
C ** START 4 - CLEAR X(1)
4 D(1)=15
X(1,1)=15
C ** START 5 - CLEAR JUST X(1,N), N=2, ..., 17
5 X(1,2)=15
DO 6 I=3,17
6 X(1,I)=0
X(1,15)=15
CALL RESET
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE ENTEXP
C DATE OF LAST CHANGE - 750828
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
IF (.NOT.EEX) GO TO 2
CALL TESTUP (RTRN)
IF (RTRN.EQ.1) GO TO 5
IF (D(13).NE.12) GO TO 1
CALL ADEXPD (RTRN)
IF (RTRN.EQ.1) GO TO 5
1 OP(1)=50
CALL COLAPS (RTRN)
IF (RTRN.EQ.1) GO TO 5
CALL ENTRUP
D(1)=15
X(1,1)=15
GO TO 3
2 IF (X(1,16).NE.0) RETURN
3 IF (M.NE.1) GO TO 4
M=2
L=2
X(1,2)=1
D(2)=1
CALL DECPT
4 D(13)=12
D(14)=15
D(15)=0
D(16)=15
EEX=.TRUE.
5 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE DECPT
C DATE OF LAST CHANGE - 750714
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
IF (.NOT.EEX) GO TO 1
EEX=.FALSE.
RETURN
1 IF (DP) RETURN
IF (M.EQ.16) RETURN
IF (D(13).NE.12) GO TO 2
IF (M.GT.11) RETURN
2 DP=.TRUE.
M=M+1
D(M)=11
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE CORECT (START)
C DATE OF LAST CHANGE - 750712
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP, TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
IF (START.EQ.2) GO TO 14
C ** START 1 - ENTRY POINT FROM "ENTRY"
TEMPF=.FALSE.
IF (.NOT.EEX) GO TO 2
EEX=.FALSE.
DO 1 I=13,16
1 D(I)=15
RETURN
2 IF (M.GT.2) GO TO 4
IF (M.EQ.1) GO TO 3
IF (X(1,1).EQ.13) GO TO 4
3 CALL CLEARX (2)
TEMPF=.TRUE.
RETURN
4 IF (.NOT.DP) GO TO 6
IF (D(M).NE.11) GO TO 5
DP=.FALSE.
GO TO 12
5 IF (L.GT.2) GO TO 7
CALL EXPON (X(1,15), X(1,16), X(1,17), 1)
IF (L.EQ.2) GO TO 9
GO TO 11
6 IF (L.EQ.1) GO TO 11
IF (L.EQ.2) GO TO 8
CALL EXPON (X(1,15), X(1,16), X(1,17), -1)
7 X(1,L)=0
GO TO 10
8 TEMPF=.TRUE.
9 X(1,L)=15
10 L=L-1
11 IF (D(13).NE.12) GO TO 12
IF (M.GT.12) GO TO 13
12 D(M)=15
13 M=M-1
RETURN
C ** START 2 - ENTRY POINT FROM "LOOK-UP"
14 IF (OP(1).EQ.0) GO TO 17
IF (OP(1).LT.70) GO TO 16
IF (X(1,1).NE.13) GO TO 15
CALL CLEARX (5)
GO TO 16
15 CALL CLEARX (2)
16 OP(1)=0
RETURN
17 IF (X(1,2).EQ.15) GO TO 18
CALL MESAGE (2, 14, RTRN)
RETURN
18 IF (X(1,1).NE.13) GO TO 19
CALL CLEARX (2)
RETURN
19 IF (P(1).NE.0) CALL RPAREN (2)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE ADEXPD (RTRN)
C DATE OF LAST CHANGE - 750702
C PURPOSE: ADD EXPONENT OF D TO THAT OF X(1)
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
TEMPF=.FALSE.
N=10*X(1,16)+X(1,17)
IF (X(1,15).EQ.13) N=-N
IF (D(15).EQ.15) D(15)=0
IF (D(16).EQ.15) D(16)=0
K=10*D(15)+D(16)
IF (D(14).EQ.13) K=-K
N=N+K
IF (IABS(N).LT.100) GO TO 3
CALL MESAGE (7, 37, RTRN)
IF (RTRN.EQ.1) GO TO 6
IF (TEMPF) RETURN
IF (N.GT.0) GO TO 1
CALL CLEARX (4)
X(1,2)=0
RETURN
1 DO 2 I=2,17
2 X(1,I)=9
C- "EXP OF X(1)" = "+ OVERFLOW"
X(1,15)=42
RETURN
3 IF (N.GE.0) GO TO 4
N=-N
X(1,15)=13
GO TO 5
4 X(1,15)=15
5 X(1,16)=N/10
X(1,17)=N-X(1,16)*10
6 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE EXPON (A, B, C, N)
C DATE OF LAST CHANGE - 740210
C ADD "N" TO THE EXPONENT "ABC" (I.E. SIGN, DIGIT, DIGIT)
IMPLICIT INTEGER (A-Z)
IF (B.EQ.15) B=0
IF (C.EQ.15) C=0
K=10*B+C
IF (A.EQ.13) K=-K
K=K+N
IF (K.GE.0) GO TO 1
K=-K
A=13
GO TO 2
1 A=15
2 B=K/10
C=K-10*B
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE RECALL (START)
C DATE OF LAST CHANGE - 750314
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 6, 7), START
C ** START 1 - EXPLICIT REGISTERS (A, PI, LST X, LST Y)
1 IF (CODE-24) 2, 3, 4
2 RN=-3
GO TO 8
3 RN=-4
GO TO 9
4 RN=CODE-40
GO TO 8
C ** START 2 - "R" REGISTERS
5 CODE=25
6 LFRC=1
CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 12
IF (TEMPF) RETURN
TEMP=1
C ** START 3 - RECALL INDICATED REGISTER (RN IN W)
7 IF (TEMP.EQ.0) GO TO 5
CALL REGNO (RTRN)
IF (RTRN.EQ.1) GO TO 12
8 IF (R(RN+5,2).NE.15) GO TO 9
CALL MESAGE (5, 43, RTRN)
IF (RTRN.EQ.1) GO TO 12
9 CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 12
IF (X(1,1).EQ.13) GO TO 10
CALL TRANS (.FALSE.)
RETURN
10 CALL TRANS (.FALSE.)
IF (X(1,1).EQ.13) GO TO 11
X(1,1)=13
RETURN
11 X(1,1)=15
12 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE STORE (START)
C DATE OF LAST CHANGE - 750612
IMPLICIT INTEGER (A-Z)
DIMENSION OPCODE(7), A(6,17)
LOGICAL TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
DATA OPCODE /30, 31, 0, 40, 41, 0, 60/
GO TO (1, 15, 24), START
C ** START 1 - LOOK FOR DESTINATION
1 IF (X(1,2).EQ.15) GO TO 2
IF (OP(1).LT.70) GO TO 3
2 CALL MESAGE (2, 13, RTRN)
RETURN
3 OPCD=0
4 LFRC=2
CODE=31
5 CALL FINDN (2, RTRN)
IF (RTRN.EQ.1) GO TO 23
IF (K.NE.0) GO TO 14
IF (CODE.NE.25) GO TO 8
GO TO 7
6 LFRC=2
CODE=25
7 CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 23
IF (.NOT.TEMPF) GO TO 14
IF (OPCD.EQ.0) GO TO 4
CODE=OPCD
GO TO 5
8 IF (CODE.NE.23) GO TO 9
N=-3
RN=-3
GO TO 16
9 IF (CODE.NE.51) GO TO 11
10 LFRC=5
CODE=51
CALL FDIGIT (RTRN)
IF (RTRN.EQ.1) GO TO 23
IF (TEMPF) GO TO 3
GO TO 25
11 IF (CODE.EQ.13 .OR. CODE.EQ.14 .OR. CODE.EQ.16 .OR.
* CODE.EQ.17 .OR. CODE.EQ.19) GO TO 13
IF (CODE.NE.28) GO TO 12
IF (OPCD.EQ.0) RETURN
GO TO 3
12 CALL MESAGE (4, 51, RTRN)
IF (RTRN.EQ.1) GO TO 23
GO TO 3
13 OPCD=OPCODE(CODE-12)
GO TO 5
14 TEMP=1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W <&DSP>)
15 IF (TEMP.EQ.0) GO TO 6
CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 23
16 KMAX=RN
DO 21 RN=N,KMAX
IF (OPCD.EQ.0) GO TO 20
K=RN+5
IF (R(K,2).NE.15) GO TO 17
CALL MESAGE (5, 45, RTRN)
IF (RTRN.EQ.1) GO TO 23
17 DO 18 I=1,17
A(1,I)=X(1,I)
A(2,I)=R(K,I)
IF (A(2,I).EQ.15) A(2,I)=0
18 CONTINUE
IF (A(2,15).EQ.0) A(2,15)=15
CALL COMBIN (A, 2, 2, RTRN)
IF (RTRN.EQ.1) GO TO 23
IF (A(1,1).EQ.0) A(1,1)=15
DO 19 I=1,17
19 R(K,I)=A(1,I)
GO TO 21
20 CALL TRANS (.TRUE.)
21 CONTINUE
22 IF (OP(1).EQ.0) OP(1)=1
23 RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N <& RN>)
24 IF (TEMP.EQ.0) GO TO 10
25 TEMP=1
IF (X(1,1).EQ.13 .OR. X(1,2).EQ.0 .OR.
* X(1,15).EQ.13 .OR. X(1,2).EQ.15) TEMP=0
DO 26 I=N,RN
K=I+1
26 UFLAG(K)=TEMP
GO TO 22
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE TRANS (STORE)
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL STORE
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
K=RN+5
IF (STORE) GO TO 4
DO 1 I=1,17
1 X(1,I)=R(K,I)
IF (X(1,2).NE.15) GO TO 3
DO 2 I=2,17
2 X(1,I)=0
X(1,15)=15
3 RETURN
4 DO 5 I=1,17
5 R(K,I)=X(1,I)
IF (R(K,2).EQ.15) R(K,2)=0
IF (R(K,1).EQ.13 .AND. R(K,2).EQ.0) R(K,1)=15
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE SCR (START)
C DATE OF LAST CHANGE - 750303
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 7, 10), START
C ** START 1 - FIND ARGUMENT
1 CODE=50
CALL CONTRL (3, 3)
IF (CODE.NE.25) GO TO 3
2 LFRC=3
CODE=25
CALL REG (RTRN)
IF (RTRN.EQ.1) GO TO 13
IF (TEMPF) GO TO 1
TEMP=1
GO TO 7
3 IF (CODE.NE.23) GO TO 4
N=-3
RN=-3
GO TO 8
4 IF (CODE.NE.51) GO TO 6
5 LFRC=4
CODE=51
CALL FDIGIT (RTRN)
IF (RTRN.EQ.1) GO TO 13
IF (TEMPF) GO TO 1
GO TO 11
6 CALL MESAGE (4, 51, RTRN)
IF (RTRN.EQ.1) GO TO 13
GO TO 1
C ** START 2 - REGISTER NUMBER(S) KNOWN (HELD IN W <&DSP>)
7 IF (TEMP.EQ.0) GO TO 2
CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 13
8 DO 9 I=N,RN
K=I+5
DO 9 J=1,17
9 R(K,J)=15
RETURN
C ** START 3 - FLAG NUMBER(S) KNOWN (HELD IN N <& RN>)
10 IF (TEMP.EQ.0) GO TO 5
11 DO 12 I=N,RN
K=I+1
12 UFLAG(K)=0
13 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE LSTKEY
C DATE OF LAST CHANGE - 750704
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC3/ CNT, TMP, S(17), T(17)
DO 1 I=1,16
T(I)=DSP(I)
1 DSP(I)=11
DSP(1)=15
2 IF (LSTK.GE.0) GO TO 4
DO 3 I=8,10
3 DSP(I)=13
GO TO 5
4 DSP(8)=0
DSP(9)=LSTK/10
DSP(10)=LSTK-10*DSP(9)
5 CALL STPNUM (1)
CALL OUTIN (3)
IF (CODE.NE.27) GO TO 7
DO 6 I=1,16
6 DSP(I)=T(I)
RETURN
7 IF (CODE.EQ.30) GO TO 4
NEXT=.TRUE.
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE FLAG (START)
C DATE OF LAST CHANGE - 750314
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 2, 3), START
C ** START 1 - FIND FLAG NUMBER
1 LFRC=6
CODE=51
C ** START 2 - FIND FLAG NUMBER FOR "IF"
2 CALL FDIGIT (RTRN)
IF (RTRN.EQ.1) GO TO 4
IF (TEMPF) RETURN
TEMP=1
C ** START 3 - FLAG NUMBER KNOWN (HELD IN N)
3 IF (TEMP.EQ.0) GO TO 1
RN=N
CALL SETUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
X(1,2)=UFLAG(RN+1)
4 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE SETUP (RTRN)
C DATE OF LAST CHANGE - 750610
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
IF (X(1,2).EQ.15) RETURN
IF (OP(1).NE.0) GO TO 2
CALL TESTUP (RTRN)
IF (RTRN.EQ.1) GO TO 4
OP(1)=50
IF (CODE.GT.79) OP(1)=71
CALL COLAPS (RTRN)
IF (RTRN.EQ.1) GO TO 4
1 CALL ENTRUP
RETURN
2 IF (OP(1).EQ.1) GO TO 5
IF (OP(1).LT.72) GO TO 3
IF (CODE.EQ.18) GO TO 3
CALL MESAGE (1, 52, RTRN)
RETURN
3 IF (X(SMAX,2).EQ.15) GO TO 1
CALL MESAGE (2, 91, RTRN)
4 RETURN
C CODE = 81, 82, ... WHEN "LANGUAGE FUNCTION" BEING FORMED
5 IF (CODE.GT.79) GO TO 3
IF (CODE.EQ.38) GO TO 6
II=RN
RN=-2
CALL TRANS (.TRUE.)
RN=II
6 CALL CLEARX (1)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE TESTUP (RTRN)
C DATE OF LAST CHANGE - 740625
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
RTRN=0
IF (X(SMAX,2).EQ.15) RETURN
IF (OP(2).LT.50) GO TO 1
IF (P(1).EQ.0) GO TO 2
1 CALL MESAGE (2, 91, RTRN)
2 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE FTSTUP (RTRN)
C DATE OF LAST CHANGE - 751020
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
* /MISC3/ CNT, TMP, S(17), T(17)
RTRN=0
DO 1 I=1,SMAX
J=SMAX-I+1
IF (X(J,2).NE.15) GO TO 2
1 CONTINUE
RETURN
2 I=I-1
K=TMP+1
IF (I.GE.K) GO TO 6
IF (X(1,2).EQ.15) GO TO 5
IF (OP(1).NE.1) GO TO 3
IF (CODE.LT.80) GO TO 5
GO TO 4
3 IF (OP(2).LT.50) GO TO 4
IF (P(1).EQ.0) GO TO 5
4 CALL MESAGE (2, 93, RTRN)
RETURN
5 I=I+1
IF (I.LT.K) GO TO 4
6 CALL SETUP (RTRN)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE ENTRUP
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
KMAX=SMAX-1
DO 1 I=1,KMAX
J=SMAX-I
K=J+1
P(K)=P(J)
OP(K)=OP(J)
DO 1 N=1,17
1 X(K,N)=X(J,N)
C- IF (X(SMAX,2).NE.15) "TURN ON 'STACK FULL' LIGHT"
CALL CLEARX (3)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE DROP (START)
C DATE OF LAST CHANGE - 750608
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
GO TO (1, 2, 3), START
C ** START 1 - DROP S(2), ..., S(SMAX)
1 J=2
GO TO 4
C ** START 2 - DROP S(3), ..., S(SMAX)
2 P(1)=P(2)
J=3
GO TO 4
C ** START 3 - DROP S(PTR), ..., S(SMAX)
3 J=PTR
4 DO 5 I=J,SMAX
K=I-1
IF (K.GT.2 .AND. X(K,2).EQ.15) GO TO 6
P(K)=P(I)
OP(K)=OP(I)
DO 5 N=1,17
5 X(K,N)=X(I,N)
6 IF (X(SMAX,2).EQ.15) RETURN
OP(SMAX)=0
P(SMAX)=0
X(SMAX,1)=15
X(SMAX,2)=15
DO 7 I=3,17
7 X(SMAX,I)=0
X(SMAX,15)=15
C- "TURN OFF 'STACK FULL' LIGHT"
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE NUMBER (START, RTRN)
C DATE OF LAST CHANGE - 750716
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /OUTPT/ SKIP, DISPLY(32), PGMPTR, READER, PRINTR
RTRN=0
IF (START.EQ.2) GO TO 6
C ** START 1 - FIND A NUMBER (0-9)
1 IF (LFRC.EQ.0) GO TO 2
CALL CONTRL (3, 3)
GO TO 3
2 CALL CONTRL (1, 3)
3 IF (CODE.GT.9) GO TO 4
W(2)=CODE
RETURN
4 IF (LFRC.NE.0) GO TO 5
NEXT=.TRUE.
RTRN=1
RETURN
5 CALL ARGMNT (1, RTRN)
IF (RTRN.EQ.1) GO TO 12
GO TO 1
C ** START 2 - NUMBER FOUND FROM EXPRESSION (HELD IN W)
6 IF (W(1).NE.13) GO TO 7
CALL MESAGE (5, 42, RTRN)
IF (RTRN.EQ.1) GO TO 12
W(1)=15
7 IF (W(15).NE.13) GO TO 8
W(2)=0
GO TO 9
8 IF (W(17).EQ.0 .AND. W(16).EQ.0) GO TO 9
CALL MESAGE (2, 41, RTRN)
RETURN
C-
9 WRITE (PRINTR,10)
10 FORMAT (10X, 'GOT TO "NUMBER AT "START 2" SOMEHOW!'/)
RTRN=1
C-
C- 9 DEST=PTR-7
C- GO TO (10, 11), DEST
C- 10 CALL P (2)
C- RETURN
C- 11 CALL STORE (2)
12 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE FINDN (START, RTRN)
C DATE OF LAST CHANGE - 750104
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
GO TO (1, 2, 3), START
1 KMAX=1
GO TO 4
2 KMAX=2
GO TO 4
3 KMAX=3
4 NEXT=.FALSE.
K=0
I=CODE
W(1)=15
W(15)=15
W(16)=0
5 CALL CONTRL (3, 3)
IF (CODE.GT.9) GO TO 6
W(17)=K
K=K+1
W(K+1)=CODE
IF (K.EQ.KMAX) RETURN
GO TO 5
6 IF (K.NE.0) GO TO 7
IF (CODE.NE.18) RETURN
CALL ARGMNT (2, RTRN)
RETURN
7 IF (CODE.NE.28) GO TO 8
K=K-1
W(17)=K-1
CODE=W(K+1)
IF (K.EQ.0) CODE=I
GO TO 5
8 IF (CODE.NE.27) GO TO 9
K=0
RETURN
9 IF (CODE.NE.26) GO TO 10
K=0
10 NEXT=.TRUE.
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE REG (RTRN)
C DATE OF LAST CHANGE - 750801
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, TEMPF
COMMON /FLAGS/ EEX, DP, NEXT, FIXFLG, STEPNO, UFLAG(11)
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
IND=0
TEMPF=.FALSE.
1 CALL FINDN (2, RTRN)
IF (RTRN.EQ.1) GO TO 18
IF (K.NE.0) GO TO 11
IF (CODE.NE.25) GO TO 3
IF (IND.NE.15) GO TO 2
CALL MESAGE (4, 46, RTRN)
IF (RTRN.EQ.1) GO TO 18
GO TO 1
2 IND=IND+1
LFRC=0
GO TO 1
3 IF (CODE.NE.23) GO TO 7
IF (R(2,2).NE.15) GO TO 5
CALL MESAGE (5, 44, RTRN)
IF (RTRN.EQ.1) GO TO 18
DO 4 I=1,17
4 W(I)=0
GO TO 11
5 DO 6 I=1,17
6 W(I)=R(2,I)
GO TO 11
7 IF (CODE.NE.22) GO TO 8
W(2)=1
W(3)=6
W(15)=15
W(16)=0
W(17)=1
GO TO 11
8 IF (CODE.EQ.26) GO TO 16
IF (CODE.EQ.27) GO TO 17
IF (CODE.NE.28) GO TO 10
IF (IND.EQ.0) GO TO 9
IND=IND-1
CODE=25
GO TO 1
9 TEMPF=.TRUE.
RETURN
10 CALL MESAGE (4, 51, RTRN)
IF (RTRN.EQ.1) GO TO 18
GO TO 1
11 IF (IND.EQ.0) GO TO 18
CALL REGNO (RTRN)
IF (RTRN.EQ.1) GO TO 18
RN=RN+5
IF (R(RN,2).NE.15) GO TO 13
CALL MESAGE (5, 44, RTRN)
IF (RTRN.EQ.1) GO TO 18
DO 12 I=1,17
12 W(I)=0
GO TO 15
13 DO 14 I=1,17
14 W(I)=R(RN,I)
15 IND=IND-1
GO TO 11
16 NEXT=.TRUE.
17 RTRN=1
18 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE RANGE (RTRN)
C DATE OF LAST CHANGE - 750225
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
* /MISC3/ CNT, TMP, S(17), T(17)
RTRN=0
TEMPF=.TRUE.
1 CALL REGNO (RTRN)
IF (RTRN.EQ.1) GO TO 6
IF (RN.NE.16) GO TO 2
CALL MESAGE (2, 41, RTRN)
RETURN
2 IF (TEMP.EQ.1) GO TO 5
N=RN
TEMPF=.FALSE.
TEMP=TEMP-1
DO 3 I=1,13
3 W(I)=T(I)
W(14)=0
DO 4 I=14,16
4 W(I+1)=T(I)
GO TO 1
5 IF (TEMPF) N=RN
IF (RN.GE.N) GO TO 6
TEMP=RN
RN=N
N=TEMP
6 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE REGNO (RTRN)
C DATE OF LAST CHANGE - 751126
C PURPOSE: CONVERT W TO INTEGER IN RN; CHECK FOR RN TOO BIG
IMPLICIT INTEGER (A-Z)
COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
IF (W(1).NE.13) GO TO 1
CALL MESAGE (5, 42, RTRN)
IF (RTRN.EQ.1) GO TO 2
W(1)=15
1 K=21
CALL INTGER
KMAX=RN
K=0
CALL INTGER
IF (RN.LE.KMAX+1) GO TO 2
CALL MESAGE (2, 41, RTRN)
2 RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE ARGMNT (START, RTRN)
C DATE OF LAST CHANGE - 760205
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
* /MISC3/ CNT, TMP, S(17), T(17)
* /OUTPT/ SKIP, DISPLY(32), PGMPTR, READER, PRINTR
RTRN=0
GO TO (1, 2, 6, 16), START
C ** START 1 - FORM GENERAL ARGUMENT?
1 IF (CODE.EQ.18) GO TO 2
CALL MESAGE (4, 51, RTRN)
RETURN
C ** START 2 - FORM GENERAL ARGUMENT!
2 IF (LFRC.NE.0) GO TO 3
CALL MESAGE (4, 55, RTRN)
RETURN
3 CODE=LFRC+80
C TMP = MINIMUM NO. OF ARGUMENTS FOR "LANGUAGE FUNCTION"
C TEMP = MAXIMUM NO. OF ARGUMENTS FOR "LANGUAGE FUNCTION"
4 TMP=1
TEMP=1
IF (CODE.GT.81 .AND. CODE.LT.86) TEMP=2
5 CALL FUNCTN (5)
RTRN=1
RETURN
C ** START 3 - RETURN ARGUMENT(S) TO "LANGUAGE FUNCTION" IN W (<&D> & T)
6 TEMP=1
7 PTR=PTR-1
IF (X(1,15).NE.13) GO TO 9
DO 8 I=1,17
8 W(I)=0
GO TO 10
9 K=6
CALL ROUND
10 CALL DROP (1)
IF (OP(1).GT.70) GO TO 17
TEMP=TEMP+1
IF (TEMP.NE.2) GO TO 13
DO 11 I=1,13
11 T(I)=W(I)
DO 12 I=14,16
12 T(I)=W(I+1)
GO TO 7
13 DO 14 I=1,13
14 D(I)=W(I)
DO 15 I=14,16
15 D(I)=W(I)
GO TO 7
C ** START 4 - RETURN TO "LANGUAGE FUNCTION" & TRY AGAIN
16 TEMP=0
17 PTR=X(1,2)-80
IF (PTR.EQ.2) OPCD=X(1,5)
IF (P(1).NE.0) GO TO 18
IF (X(1,1).EQ.13) GO TO 18
CALL DROP (1)
IF (OP(1).LT.70) GO TO 19
IF (X(1,2).LT.16) OP(1)=0
GO TO 19
18 OP(1)=0
CALL CLEARX (5)
19 GO TO (22, 23, 24, 25, 25, 25, 20, 26, 26), PTR
20 WRITE (PRINTR,21) PTR
21 FORMAT (10X,'*** ERROR: RETURN CODE =',I3,' IN ARGMNT')
RETURN
22 CALL RECALL (3)
RETURN
23 CALL STORE (2)
RETURN
24 CALL SCR (2)
RETURN
25 CALL FDGIT2 (RTRN)
RETURN
26 CALL NUMBER (2, RTRN)
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE INTGER
C DATE OF LAST CHANGE - 750731
IMPLICIT INTEGER (A-Z)
COMMON /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
* /MISC3/ CNT, TMP, S(17), T(17)
RN=0
IF (K.GT.0) GO TO 3
1 DO 2 I=1,17
2 S(I)=W(I)
GO TO 5
3 IF (R(K,2).EQ.15) RETURN
DO 4 I=1,17
4 S(I)=R(K,I)
5 IF (S(15).EQ.13) RETURN
K=S(16)*10+S(17)+1
IF (K.LT.13) GO TO 6
RN=99999
RETURN
6 DO 7 I=1,K
7 RN=RN*10+S(I+1)
IF (S(1).EQ.13) RN=-RN
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE ROUND
C DATE OF LAST CHANGE - 750123
C PURPOSE: ROUND X(1,I) TO K DIGITS & PUT RESULT IN W(I)
IMPLICIT INTEGER (A-Z)
COMMON /STACK/ P(10), X(10,17), OP(10), D(16), DSP(16), SMAX
* /MISC1/ L, M, FIX, SCI, ERROR, R(21,17), W(17), LFRC
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
* /MISC3/ CNT, TMP, S(17), T(17)
1 DO 2 I=1,17
2 W(I)=X(1,I)
IF (K.NE.15) GO TO 3
W(15)=42
RETURN
3 IF (W(2).EQ.15) W(2)=0
CNT=K+2
IF (W(CNT)-5) 11, 4, 7
C TEST DIGIT = 5 (TEST FURTHER)
4 CNT=14
KMAX=K+3
5 IF (W(CNT).GT.0) GO TO 7
IF (CNT.EQ.KMAX) GO TO 6
CNT=CNT-1
GO TO 5
6 CNT=K+1
IF (2*(W(CNT)/2) .EQ. W(CNT)) GO TO 11
C ROUND UP
7 CNT=K+1
8 W(CNT)=W(CNT)+1
IF (W(CNT).LT.10) GO TO 11
W(CNT)=W(CNT)-10
CNT=CNT-1
IF (CNT.GT.1) GO TO 8
C W(2) OVERFLOWED; SHIFT RIGHT & SET W(2)=1
CNT=K+2
9 W(CNT)=W(CNT-1)
IF (CNT.LE.3) GO TO 10
CNT=CNT-1
GO TO 9
10 W(2)=1
K=K+1
CALL EXPON (W(15), W(16), W(17), 1)
IF (W(16).LT.10) GO TO 11
K=15
GO TO 1
C PUT 0'S IN REMAINDER OF W
11 KMAX=K+1
DO 12 I=KMAX,13
12 W(I+1)=0
RETURN
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE FDIGIT (RTRN)
C DATE OF LAST CHANGE - 760208
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
C ** START 1 - FIND A DIGIT (0-9, A)
TEMPF=.FALSE.
1 CALL CONTRL (3, 3)
IF (CODE.GT.9) GO TO 2
N=CODE
GO TO 3
2 IF (CODE.NE.23) GO TO 4
N=10
3 RN=N
RETURN
4 IF (CODE.NE.28) GO TO 5
TEMPF=.TRUE.
RETURN
5 CALL ARGMNT (1, RTRN)
IF (RTRN.EQ.1) RETURN
GO TO 1
END
C///////////////////////////////////////////////////////////////////////
SUBROUTINE FDGIT2 (RTRN)
C DATE OF LAST CHANGE - 760208
IMPLICIT INTEGER (A-Z)
LOGICAL TEMPF
COMMON /INPUT/ CODE, DECODE, EXPR(50), KEY, LSTK
* /MISC2/ I, J, K, KMAX, N, OPCD, PTR, RN, TEMP, TEMPF
RTRN=0
C ** START 2 (OF "FDIGIT") - DIGIT HAS BEEN FOUND FROM EXPRESSION
IF (TEMP.EQ.0) GO TO 2
CALL RANGE (RTRN)
IF (RTRN.EQ.1) GO TO 6
IF (RN.GT.11) GO TO 1
IF (N.LT.11) GO TO 2
1 CALL MESAGE (2, 41, RTRN)
RETURN
2 J=PTR-3
GO TO (3, 4, 5), J
3 CALL SCR (3)
RETURN
4 CALL STORE (3)
RETURN
5 CALL FLAG (3)
6 RETURN
END